home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / gnu_st.lha / gnu_st / smalltalk-1.1.1 / stix / genevt.st < prev    next >
Text File  |  1991-09-12  |  13KB  |  370 lines
  1. "======================================================================
  2. |
  3. | Copyright (C) 1990, 1991 Free Software Foundation, Inc.
  4. | Written by Steve Byrne.
  5. |
  6. | This file is part of GNU Smalltalk.
  7. |
  8. | GNU Smalltalk is free software; you can redistribute it and/or modify it
  9. | under the terms of the GNU General Public License as published by the Free
  10. | Software Foundation; either version 1, or (at your option) any later version.
  11. | 
  12. | GNU Smalltalk is distributed in the hope that it will be useful, but WITHOUT
  13. | ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
  14. | FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
  15. | details.
  16. | 
  17. | You should have received a copy of the GNU General Public License along with
  18. | GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
  19. | Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  
  20. |
  21.  ======================================================================"
  22.  
  23.  
  24. "
  25. |     Change Log
  26. | ============================================================================
  27. | Author       Date       Change 
  28. | sbyrne     24 May 90      created.
  29. |
  30. "
  31.  
  32. Smalltalk at: #DataTypeMap put: Dictionary new.
  33. Smalltalk at: #DataTypeSize put: Dictionary new.
  34. Smalltalk at: #MapInfo put: Dictionary new!
  35.  
  36.  
  37. DataTypeMap at: #card8 put: #ubyte.
  38. DataTypeMap at: #bool put: #byte.
  39. DataTypeMap at: #keycode put: #byte.
  40. DataTypeMap at: #button put: #byte.
  41. DataTypeMap at: #card16 put: #uword.
  42. DataTypeMap at: #bitmask put: #uword.
  43. DataTypeMap at: #int16 put: #word.
  44. DataTypeMap at: #setOfKeyButMask put: #word.
  45. DataTypeMap at: #card32 put: #ulong.
  46. DataTypeMap at: #window put: #long.
  47. DataTypeMap at: #drawable put: #long.
  48. DataTypeMap at: #atom put: #long.
  49. DataTypeMap at: #colormap put: #long.
  50. DataTypeMap at: #timestamp put: #long.
  51. DataTypeMap at: #keymap put: 'getUnpaddedString: 31'.
  52.  
  53.  
  54. DataTypeSize at: #card8 put: 1.
  55. DataTypeSize at: #bool put: 1.
  56. DataTypeSize at: #keycode put: 1.
  57. DataTypeSize at: #button put: 1.
  58. DataTypeSize at: #card16 put: 2.
  59. DataTypeSize at: #bitmask put: 2.
  60. DataTypeSize at: #int16 put: 2.
  61. DataTypeSize at: #setOfKeyButMask put: 2.
  62. DataTypeSize at: #card32 put: 4.
  63. DataTypeSize at: #window put: 4.
  64. DataTypeSize at: #drawable put: 4.
  65. DataTypeSize at: #atom put: 4.
  66. DataTypeSize at: #colormap put: 4.
  67. DataTypeSize at: #timestamp put: 4.
  68. DataTypeSize at: #keymap put: 31.
  69.  
  70.  
  71. MapInfo at: #window put: 'self mappedId: '.
  72. MapInfo at: #drawable put: 'self mappedId: '.
  73. MapInfo at: #atom put: 'self mappedId: '.
  74. MapInfo at: #colormap put: 'self mappedId: '
  75. !
  76.  
  77.  
  78. Object subclass: #XEvent
  79.        instanceVariableNames: 'sequenceNumber'
  80.        classVariableNames: 'EventMap'
  81.        poolDictionaries: ''
  82.        category: 'X hacking'
  83. !
  84.  
  85. !Object class methodsFor: 'hacking'!
  86.  
  87. genErrorInit
  88.     | stream |
  89.     stream _ FileStream open: 'Xerr.st' mode: 'w'.
  90.     stream close.
  91. !
  92.  
  93. genEventInit
  94.     | stream |
  95.     stream _ FileStream open: 'Xevt.st' mode: 'w'.
  96.     stream close.
  97. !
  98.  
  99. genErrorClass: className args: anArray
  100.     | stream |
  101.     stream _ FileStream open: 'Xerr.st' mode: 'a'.
  102.     self genErrorClassDef: className on: stream args: anArray.
  103.     self genErrorClassMethods: className on: stream args: anArray.
  104.     stream nextPut: Character newPage.
  105.     stream nl.
  106.     stream close
  107. !
  108.  
  109. genEventClass: className args: anArray
  110.     | stream |
  111.     stream _ FileStream open: 'Xevt.st' mode: 'a'.
  112.     self genEventClassDef: className on: stream args: anArray.
  113.     self genEventClassMethods: className on: stream args: anArray.
  114.     stream nextPut: Character newPage.
  115.     stream nl.
  116.     stream close
  117. !
  118.  
  119. " private definitions "
  120.  
  121. genErrorClassDef: className on: aStream args: anArray
  122.     self genClassDef: 'Error' forClass: className on: aStream args: anArray
  123. !
  124.  
  125. genEventClassDef: className on: aStream args: anArray
  126.     self genClassDef: 'Event' forClass: className on: aStream args: anArray
  127. !
  128.  
  129. genClassDef: type forClass: className on: aStream args: anArray
  130.     'X', type, ' subclass: #' printOn: aStream.
  131.     className, type printOn: aStream.
  132.     aStream nl.
  133.     self genClassInstVars: anArray on: aStream.
  134. '    classVariableNames: ''''
  135.     poolDictionaries: ''''
  136.     category: ''X hacking''
  137. !' printOn: aStream.
  138.     aStream nl.
  139.     aStream nl
  140. !
  141.  
  142. genErrorClassMethods: className on: aStream args: anArray
  143.     self genClassMethods: 'Error' forClass: className on: aStream args: anArray
  144. !
  145.  
  146. genEventClassMethods: className on: aStream args: anArray
  147.     self genClassMethods: 'Event' forClass: className on: aStream args: anArray
  148. !
  149.  
  150. genClassMethods: type forClass: className on: aStream args: anArray
  151.     | totalBytes dataType | 
  152.     '!', className, type, ' class methodsFor: ''instance creation''!
  153.  
  154. newFrom: aStream
  155.     ^self new initFrom: aStream
  156. !!
  157.  
  158. ' printOn: aStream.
  159.     self genAccessorMethods: type forClass: className on: aStream args: anArray.
  160.     '!', className, type, ' methodsFor: ''private''!
  161.  
  162. ' printOn: aStream.
  163. 'initFrom: aStream' printOn: aStream.  aStream nl.
  164.     totalBytes _ 0.
  165.     anArray do:
  166.     [ :var | '    ' printOn: aStream.
  167.          var size > 1
  168.              ifTrue: [ (var at: 1) printOn: aStream.
  169.                    ' _ ' printOn: aStream ].
  170.          'aStream ' printOn: aStream.
  171.          dataType _ (var at: var size).
  172.                  (self mapType: dataType) printOn: aStream.
  173.          totalBytes _ totalBytes + (self typeSize: dataType).
  174.          '. ' printOn: aStream. aStream nl ].
  175.     '    aStream skipBytes: ' printOn: aStream.
  176.     (31 - totalBytes) printOn: aStream.
  177.     aStream nl.
  178.     '!!' printOn: aStream.
  179.     aStream nl.
  180.     aStream nl.
  181. !
  182.  
  183. genAccessorMethods: type forClass: className on: aStream args: anArray
  184.     | name varType |
  185.     '!', className, type, ' methodsFor: ''accessing''!
  186.  
  187. ' printOn: aStream.
  188.     anArray do: 
  189.     [ :var | var size > 1
  190.              ifTrue: [ name _ (var at: 1).
  191.                    varType _ (var at: var size).
  192.                    name printOn: aStream.
  193.                    aStream nl.
  194.                    '    ^' printOn: aStream.
  195.                                (MapInfo includesKey: varType)
  196.                    ifTrue: [ (MapInfo at: varType), ' ',
  197.                          name printOn: aStream]
  198.                    ifFalse: [ name printOn: aStream ].
  199.                    aStream nl.
  200.                    '!' printOn: aStream.
  201.                    aStream nl.
  202.                    aStream nl ].
  203.         ].
  204.     '!' printOn: aStream.
  205.     aStream nl.
  206.     aStream nl.
  207. !
  208.  
  209. mapType: aType
  210.     ^DataTypeMap at: aType
  211.          ifAbsent: [ self error: 'no such type: ', (aType printString) ]
  212. !
  213.  
  214. typeSize: aType
  215.     ^DataTypeSize at: aType
  216.              ifAbsent: [ self error: 'no such type: ', (aType printString) ]
  217. !    
  218.  
  219. genClassInstVars: anArray on: aStream
  220.     | varName |
  221.     aStream tab.
  222.     'instanceVariableNames: ''' printOn: aStream.
  223.     anArray do: 
  224.     [ :var | var size = 2
  225.              ifTrue: [ (#(sequenceNumber)
  226.                    indexOf: (varName _ var at: 1)) = 0
  227.                    ifTrue: [ varName, ' ' printOn: aStream ] ]
  228.              ].
  229.     '''' printOn: aStream.
  230.     aStream nl
  231. !!
  232.  
  233. Object genEventInit.
  234. Object genEventClass: 'KeyPress' 
  235.     args: #((detail keycode) (sequenceNumber card16) (time timestamp) 
  236.         (root window) (event window) (child window) 
  237.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  238.         (state setOfKeyButMask) (sameScreen bool)).
  239. Object genEventClass: 'KeyRelease' 
  240.     args: #((detail keycode) (sequenceNumber card16) (time timestamp) 
  241.         (root window) (event window) (child window) 
  242.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  243.         (state setOfKeyButMask) (sameScreen bool)).
  244. Object genEventClass: 'ButtonPress' 
  245.     args: #((detail button) (sequenceNumber card16) (time timestamp) 
  246.         (root window) (event window) (child window) 
  247.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  248.         (state setOfKeyButMask) (sameScreen bool)).
  249. Object genEventClass: 'ButtonRelease' 
  250.     args: #((detail button) (sequenceNumber card16) (time timestamp) 
  251.         (root window) (event window) (child window) 
  252.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  253.         (state setOfKeyButMask) (sameScreen bool)).
  254. Object genEventClass: 'MotionNotify' 
  255.     args: #((detail card8) (sequenceNumber card16) (time timestamp) 
  256.         (root window) (event window) (child window) 
  257.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  258.         (state setOfKeyButMask) (sameScreen bool)).
  259. Object genEventClass: 'EnterNotify' 
  260.     args: #((detail card8) (sequenceNumber card16) (time timestamp) 
  261.         (root window) (event window) (child window) 
  262.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  263.         (state setOfKeyButMask) (mode card8) (focus card8)).
  264. Object genEventClass: 'LeaveNotify' 
  265.     args: #((detail card8) (sequenceNumber card16) (time timestamp) 
  266.         (root window) (event window) (child window) 
  267.         (rootX int16) (rootY int16) (eventX int16) (eventY int16)
  268.         (state setOfKeyButMask) (mode card8) (focus card8)).
  269. Object genEventClass: 'FocusIn' 
  270.     args: #((detail card8) (sequenceNumber card16) (event window) 
  271.         (mode card8)).
  272. Object genEventClass: 'FocusOut' 
  273.     args: #((detail card8) (sequenceNumber card16) (event window) 
  274.         (mode card8)).
  275.  
  276. Object genEventClass: 'KeymapNotify' 
  277.     args: #((keys keymap)).
  278.  
  279. Object genEventClass: 'Expose' 
  280.     args: #((card8) (sequenceNumber card16) (window window) 
  281.         (x card16) (y card16) (width card16) (height card16)
  282.         (count card16)).
  283.  
  284. Object genEventClass: 'GraphicsExposure' 
  285.     args: #((card8) (sequenceNumber card16) (drawable drawable) 
  286.         (x card16) (y card16) (width card16) (height card16)
  287.         (minorOp card16) (count card16) (majorOp card8)).
  288. Object genEventClass: 'NoExposure' 
  289.     args: #((card8) (sequenceNumber card16) (drawable drawable) 
  290.         (minorOp card16) (majorOp card8)).
  291. Object genEventClass: 'VisibilityNotify' 
  292.     args: #((card8) (sequenceNumber card16) (window window) 
  293.         (state card8)).
  294. Object genEventClass: 'CreateNotify' 
  295.     args: #((card8) (sequenceNumber card16) (parent window) (window window)
  296.         (x int16) (y int16) (width card16) (height card16)
  297.         (borderWidth card16) (overrideRedirect bool)).
  298. Object genEventClass: 'DestroyNotify' 
  299.     args: #((card8) (sequenceNumber card16) (event window) (window window)).
  300. Object genEventClass: 'UnmapNotify' 
  301.     args: #((card8) (sequenceNumber card16) (event window) (window window)
  302.         (fromConfigure bool)).
  303. Object genEventClass: 'MapNotify' 
  304.     args: #((card8) (sequenceNumber card16) (event window) (window window)
  305.         (overrideRedirect bool)).
  306. Object genEventClass: 'MapRequest' 
  307.     args: #((card8) (sequenceNumber card16) (parent window) (window window)).
  308. Object genEventClass: 'ReparentNotify' 
  309.     args: #((card8) (sequenceNumber card16) 
  310.         (event window) (window window) (parent window)
  311.         (x int16) (y int16) (overrideRedirect bool)).
  312. Object genEventClass: 'ConfigureNotify' 
  313.     args: #((card8) (sequenceNumber card16) 
  314.         (event window) (window window) (aboveSibling window)
  315.         (x int16) (y int16) (width card16) (height card16)
  316.         (borderWidth card16) (overrideRedirect bool)).
  317. Object genEventClass: 'ConfigureRequest' 
  318.     args: #((stackMode card8) (sequenceNumber card16) 
  319.         (parent window) (window window) (sibling window)
  320.         (x int16) (y int16) (width card16) (height card16)
  321.         (borderWidth card16) (valueMask bitmask)).
  322. Object genEventClass: 'GravityNotify' 
  323.     args: #((card8) (sequenceNumber card16) 
  324.         (event window) (window window)
  325.         (x int16) (y int16)).
  326. Object genEventClass: 'ResizeRequest' 
  327.     args: #((card8) (sequenceNumber card16) 
  328.         (window window)
  329.         (width card16) (height card16)).
  330. Object genEventClass: 'CirculateNotify' 
  331.     args: #((card8) (sequenceNumber card16) 
  332.         (event window) (window window) (window)
  333.         (place card8)).
  334. Object genEventClass: 'CirculateRequest' 
  335.     args: #((card8) (sequenceNumber card16) 
  336.         (parent window) (window window) (card32)
  337.         (place card8)).
  338. Object genEventClass: 'PropertyNotify' 
  339.     args: #((card8) (sequenceNumber card16) 
  340.         (window window) (atom atom)
  341.         (time timestamp) (state card8))
  342. !
  343.  
  344. Object genEventClass: 'SelectionClear' 
  345.     args: #((card8) (sequenceNumber card16) 
  346.         (time timestamp) (owner window) (selection atom)).
  347. Object genEventClass: 'SelectionRequest' 
  348.     args: #((card8) (sequenceNumber card16) 
  349.         (time timestamp) (owner window) (requestor window)
  350.         (selection atom) (target atom) (property atom)).
  351. Object genEventClass: 'SelectionNotify' 
  352.     args: #((card8) (sequenceNumber card16) 
  353.         (time timestamp) (requestor window)
  354.         (selection atom) (target atom) (property atom)).
  355. Object genEventClass: 'ColormapNotify' 
  356.     args: #((card8) (sequenceNumber card16) 
  357.         (window window) (colormap colormap)
  358.         (new bool) (state card8)).
  359. Object genEventClass: 'ClientMessage' 
  360.     args: #((format card8) (sequenceNumber card16) 
  361.         (window window) (type atom)
  362.         "says: 20 data").
  363. Object genEventClass: 'MappingNotify' 
  364.     args: #((card8) (sequenceNumber card16) 
  365.         (request card8) (keycode keycode)
  366.         (count card8)).
  367. !
  368.  
  369. Smalltalk quitPrimitive!
  370.